home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1992 June: ROMin Holiday / ADC Developer CD (1992-06) (''ROMin Holiday'')_iso / Developer Connection - 06-1992.iso / Development Platforms / LISP Related / U. Mass AI & LISP Tools / MODULES / DACTN / DACTN-Browser.lisp next >
Encoding:
Text File  |  1990-06-24  |  38.1 KB  |  822 lines  |  [TEXT/CCL ]
  1. ; (c) Copyright 1990 by University of Massachusetts. All rights reserved.
  2. ; This software was conceived, designed, and written by Dan Suthers 
  3. ; while supported by the National Science Foundation under grant number
  4. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  5. ; CA.  Partial support was also received from the Office of Naval Research
  6. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  7. ; Mr. Suthers created this software under his own initiative while in an 
  8. ; academic relationship with the University of Massachusetts.  The above
  9. ; copyright notice was a condition placed by University lawyers on approval
  10. ; of distribution of this software by Apple Computer, and is not meant to
  11. ; imply that this software was created in an employment or "work for hire"
  12. ; relationship between the University and Mr. Suthers.
  13. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14. ; File:         DACTN-Browser.lisp
  15. ; Author:       Dan Suthers
  16. ; Created:      09-Aug-88 00:20:26
  17. ; Modified:     22-Jun-90 02:38:38 (Dan Suthers)
  18. ; Language:     Common Lisp
  19. ; Package:      DACTN
  20. ;
  21. ; Description:  Graphical browsing and editing of DACTNs.
  22. ;
  23. ; (c) Copyright 1988, by Daniel D. Suthers
  24. ;                        Department of Computer and Information Science
  25. ;                        University of Massachusetts
  26. ;                        Amherst, Massachusetts 01003
  27. ;
  28. ; This software was conceived, designed, and written by Dan Suthers 
  29. ; while supported by the National Science Foundation under grant number
  30. ; MDR 8751362, and by a fellowship from Apple Computer, Inc., Cupertino,
  31. ; CA.  Partial support was also received from the Office of Naval Research
  32. ; under a University Research Initiative Grant, contract N00014-86-K-0764.
  33. ; I wish to acknowledge the generous support of Beverly Woolf, who obtained 
  34. ; the above grants and encouraged me to pursue my own research interests in
  35. ; her lab.  This work would not have been possible without the resources and
  36. ; stimulating environment of the Computer and Information Science department.
  37. ;
  38. ; Permission to use, modify, and distribute this software is granted subject 
  39. ; to the following restrictions and understandings:
  40. ; 1. The file header, including this notice, shall be retained, and may be
  41. ;    extended to include documentation of modifications to the software.
  42. ; 2. This material is for nonprofit educational and research purposes only.
  43. ;    Users are requested, but not required, to inform Mr. Suthers of any 
  44. ;    noteworthy uses of this software.
  45. ; 3. Mr. Suthers and the University of Massachusetts make no warrantee or
  46. ;    representation that the operation of this software will be error free,
  47. ;    and are under no obligation to provide any services.
  48. ; 4. Any user of such software agrees to indemnify and hold harmless Mr.
  49. ;    Suthers and the University of Massachusetts from all claims arising 
  50. ;    out of the use or misuse of this software, or arising out of any 
  51. ;    accident, injury, or damage whatsoever, and from all costs, counsel
  52. ;    fees, and liabilities incurred in or about any such claim, action, or
  53. ;    proceeding brought thereon.
  54. ; 5. All materials and reports developed as a consequence of the use of 
  55. ;    this software shall duly acknowledge such use, in accordance with
  56. ;    the usual standards of acknowledging credit in academic research.
  57. ;
  58. ; Status:       Usable.  Recommend rewriting for specialized interfaces.
  59. ;
  60. ; Tested:       Macintosh II Coral/Allegro 03-Nov-88 00:31:11
  61. ;
  62. ; Changes:  
  63. ;   04-Sep-88 ARG-GEN editable; can no longer delete referenced node;
  64. ;     can mouse recursive dactn to graph it; misc. cleanup.
  65. ;   23-Sep-88 Reuses same window when regraphing (window destruction and
  66. ;     creation was annoying; now it preserves the size of the window too);
  67. ;     Dactns saved pretty printed; Trace added; Interpret and Trace options
  68. ;     on menu.  Thanks to Lauren Blau for suggestions.
  69. ;   25-Sep-88 Updating for new grapher mouse method implementation.  Now
  70. ;     all actions are available on the first menu.
  71. ;   28-Sep-88 Keeps track of modified DACTNs; menu access to this list.
  72. ;     When adding Action or Test, you can specify New and get a Fred window.
  73. ;   26-Oct-88 Choice of labeling graphed dactn nodes with name or associated
  74. ;     action; box types changed updated consistent with other grapher code;
  75. ;     One less menu selection required by get-arc-from-user.
  76. ;   01-Nov-88 Updated for SM changes.
  77. ;   14-Nov-88 Graphs "orphan" nodes at top of screen; doesn't put up menu
  78. ;     for Delete Arc when there is only one arc.
  79. ;   09-Dec-88 Minor change to graphed DACTN window title.
  80. ;   27-Dec-88 Eliminating graph-node-parents.
  81. ;   17-Oct-89 Interpret-dactn now called by eval-enqueue when invoked from
  82. ;     window or menu. Dave Shaffer had a problem with other windows getting
  83. ;     locked up, until I did this.
  84. ;  07-Nov-89 Wrote menu-item-update for label-type-item and trace-item.
  85. ;  30-Jan-90 Updated for version 1.3.1.
  86. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  87.  
  88. (in-package :DACTN)
  89.  
  90. (export '(
  91.           dactn->graph-view
  92.           dactn-modified
  93.           dactn-unmodified
  94.           graph-dactn
  95.           modified-dactns
  96.           ))
  97.  
  98. (require :misc)
  99. (require :sm)
  100. (require :smedit)
  101. (require :dactns)
  102. (require :dialogue)
  103. (require :grapher)
  104.  
  105. ;;; To get past ccl compiler bug: it seems to hit wind:symbols before
  106. ;;; executing the require that creates the package, and gives a "no
  107. ;;; package WIND" error.
  108. (use-package :wind) 
  109.  
  110. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  111. ;;; Used to fill the OBJECT slot of a GRAPH-NODE.
  112.  
  113. (defstruct (OBJECT-SPEC 
  114.             (:type list)
  115.             (:constructor make-object-spec (type owner itself)))
  116.   (TYPE   :dactn :type (member :dactn :dactn-node :dactn-arc :exit))
  117.   (OWNER  nil    :type symbol) ; a dactn name
  118.   (ITSELF nil    :type t))
  119.  
  120. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  121. ;;; Keeping track of modified DACTNS for saving to file ...
  122.  
  123. (let ((*modified-dactns* nil))
  124.   (defun DACTN-MODIFIED (dactn)
  125.     "dactn-modified <dactn> 
  126.   records the dactn as modified."
  127.     (setf *modified-dactns* (adjoin dactn *modified-dactns*)))
  128.   (defun DACTN-UNMODIFIED (dactn) 
  129.     "dactn-unmodified <dactn>
  130.   removes the dactn from the list of modified dactns."
  131.     (setf *modified-dactns* (delete dactn *modified-dactns*)))
  132.   (defun MODIFIED-DACTNS () 
  133.     "modified-dactns 
  134.   returns a list of dactns recorded as being modified."
  135.     *modified-dactns*)
  136.   )
  137.  
  138. ;;; We redefine this to mark a dactn as modified if the user uses sm:edits.
  139.  
  140. (setf (sm:type-info 'dactn :after-edit)
  141.       '(lambda (d)
  142.          (dactn-modified d)
  143.          (initialize-dactn d)))
  144.  
  145. ;;; If nil, node name used; if T, action name used in graphs.
  146.  
  147. (defvar *LABEL-USING-ACTION-NAMES* nil)
  148.  
  149. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  150.  
  151. (defun GRAPH-DACTN (dactn &key (node-font '("monaco" 9)))
  152.   "graph-dactn <dactn>                                              [Function]
  153.   Puts up a grapher window and graphs the DACTN in it."
  154.   (check-type dactn    symbol)
  155.   (assert (sm:gets 'dactn dactn) (dactn) "[GRAPH-DACTN] ~S is not a dactn name.")
  156.   (ccl:oneof grapher:*graph-window* 
  157.              :graph-view (dactn->graph-view dactn :node-font node-font)
  158.              :window-title 
  159.              (let ((*print-case* :capitalize))
  160.                (format nil "DACTN ~A" dactn))))
  161.  
  162. (defun DACTN-MOUSE-METHOD (gw gv gn)
  163.   ;; Bypassing usual menu approach since we want menus to be sensitive to node type.
  164.   (declare (symbol gv gn))
  165.   (let ((object-spec
  166.           (grapher:graph-node-object (sm:gets 'grapher:graph-node gn))))
  167.     (case (object-spec-type object-spec)
  168.       ((:dactn)      (dactn-mouse-method-for-dactn      gw gv gn object-spec))
  169.       ((:dactn-node) (dactn-mouse-method-for-dactn-node gw gv gn object-spec))
  170.       ((:dactn-arc)  (dactn-mouse-method-for-dactn-arc  gw gv gn object-spec))
  171.       ((:exit)       (dactn-mouse-method-for-exit       gw gv gn object-spec)))))
  172.  
  173. (defun CONS-IN-MIDDLE-OF-LIST (object list)
  174.   (if (null list) 
  175.     (list object)
  176.     (cons (first list)
  177.           (cons-in-middle-of-list-r object (rest list) 2))))
  178.  
  179. (defun CONS-IN-MIDDLE-OF-LIST-R (object remaining-list in-so-far)
  180.   (if (<= (length remaining-list) in-so-far)
  181.     (cons object remaining-list)
  182.     (cons (first remaining-list)
  183.           (cons-in-middle-of-list-r object (rest remaining-list) (1+ in-so-far)))))
  184.         
  185. (defun DACTN->GRAPH-VIEW (dactn &key (node-font '("monaco" 9)))
  186.   (check-type dactn symbol)
  187.   (assert (sm:gets 'dactn dactn) (dactn) "[DACTN->GRAPH-VIEW] Unknown DACTN ~S" dactn)
  188.   (let* ((dactn-struct (sm:gets 'dactn dactn))
  189.          (dactn-node-defs (dactn-nodes dactn-struct))
  190.          (dactn-nodes->graph-nodes nil)
  191.          (dactn-arc-graph-nodes nil)
  192.          (non-orphans nil))
  193.     (declare (list dactn-node-defs dactn-nodes->graph-nodes dactn-arc-graph-nodes
  194.                    recursive-dactns->graph-nodes non-orphans))
  195.           
  196.     ;; Define all the graph nodes for dactn nodes.
  197.     (dolist (name+struct dactn-node-defs)
  198.       (declare (cons name+struct))
  199.       (let ((node-name (gensym "GraphedDactnNode-")))
  200.         (push 
  201.          (cons (car name+struct)
  202.                (grapher:create-graph-node
  203.                 node-name
  204.                 (if *label-using-action-names*
  205.                   (symbol-name (second (dactn-node-action (cdr name+struct))))
  206.                   (symbol-name (car name+struct)))                    ; LABEL
  207.                 nil                                                   ; CHILDREN 
  208.                 (if (eq (first (dactn-node-action (cdr name+struct)))
  209.                         :dactn)
  210.                   :round-rect
  211.                   :rect)                                              ; BOX-STYLE 
  212.                 t                                                     ; CONNECTOR
  213.                 (make-object-spec :dactn-node dactn name+struct)))    ; OBJECT
  214.          dactn-nodes->graph-nodes)))
  215.     
  216.     ;; For each arc, define a graph node and insert appropriate graph node pointers.
  217.     (dolist (name+struct dactn-node-defs)
  218.       (declare (cons name+struct))
  219.  
  220.       ;; Reverse operation to get the arcs drawn in the right order easily.
  221.       (do* ((arc-ptr (reverse (dactn-node-arcs (cdr name+struct))) (cdr arc-ptr))
  222.             (arc nil)
  223.             (arc-count (length (dactn-node-arcs (cdr name+struct))) (1- arc-count))
  224.             (number-arcs (> arc-count 1)))
  225.           ((null arc-ptr))
  226.         (declare (list arc-ptr arc) (fixnum arc-count))
  227.         (setf arc (first arc-ptr))
  228.         ;; This is needed to identify "orphan" nodes to be graphed.
  229.         (if (third arc) ; Null third arc -> EXIT which has no dactn node.
  230.           (pushnew (cdr (assoc (third arc) dactn-nodes->graph-nodes))
  231.                    non-orphans))
  232.         (let ((arc-name (gensym "GraphedDactnArc-")))
  233.           (push 
  234.            (grapher:create-graph-node
  235.             arc-name
  236.             (if number-arcs                                                 ; LABEL
  237.               (format nil "~A: ~A"
  238.                       arc-count
  239.                       (string-capitalize (symbol-name (first arc))))
  240.               (format nil "~A" (string-capitalize (symbol-name (first arc)))))
  241.             nil                                                             ; CHILDREN 
  242.             :none                                                           ; BOX-STYLE 
  243.             nil                                                             ; CONNECTOR
  244.             (make-object-spec :dactn-arc dactn (cons (car name+struct) arc))) ; OBJECT
  245.            dactn-arc-graph-nodes)
  246.           
  247.           ;; Create children if needed and link.
  248.           (case (second arc)
  249.             ;; Node children have been created: link to nodes at both ends of the arc.
  250.             ((:goto) 
  251.              (setf (grapher:graph-node-children
  252.                     (sm:gets 'grapher:graph-node arc-name))
  253.                    (list (cdr (assoc (third arc) dactn-nodes->graph-nodes))))
  254.              (push arc-name
  255.                    (grapher:graph-node-children
  256.                     (sm:gets 'grapher:graph-node
  257.                              (cdr (assoc (car name+struct) dactn-nodes->graph-nodes))))))
  258.  
  259.             ;; Exit: arc has no argument.  Make bogus graph node child, link.
  260.             ((:exit)
  261.              (push arc-name
  262.                    (grapher:graph-node-children
  263.                     (sm:gets 'grapher:graph-node
  264.                              (cdr (assoc (car name+struct) dactn-nodes->graph-nodes)))))
  265.              (setf (grapher:graph-node-children
  266.                     (sm:gets 'grapher:graph-node arc-name))
  267.                    (list (grapher:create-graph-node
  268.                           (gensym "GRAPHED-EXIT-")
  269.                           "EXIT"                                      ; LABEL
  270.                            nil                                        ; CHILDREN 
  271.                            :rect                                      ; BOX-STYLE 
  272.                            t                                          ; CONNECTOR
  273.                            (make-object-spec :exit dactn nil))))))))) ; OBJECT
  274.     
  275.     ;; Make the graph view, with a node corresponding to the DACTN being the root.
  276.     (grapher:create-graph-view
  277.      (utils:unique-symbol (format nil "~A " dactn))
  278.      (cons-in-middle-of-list                                               ; ROOTS
  279.       (grapher:create-graph-node
  280.        (gensym "GRAPHED-DACTN-")
  281.        (symbol-name dactn)                                 ; Label
  282.        (if (dactn-start-node dactn-struct)                 ; Children 
  283.          (list (cdr (assoc (dactn-start-node dactn-struct)
  284.                            dactn-nodes->graph-nodes))))
  285.        :oval                                               ; Box-Style 
  286.        t                                                   ; Connector
  287.        (make-object-spec :dactn dactn nil))                ; Object
  288.       ;; Including "orphan" dactn nodes as roots.
  289.       (mapcan #'(lambda (dn+gn)
  290.                   (declare (cons dn+gn))
  291.                   (unless (or (member (cdr dn+gn) non-orphans)
  292.                               (eq (car dn+gn) (dactn-start-node dactn-struct)))
  293.                     (list (cdr dn+gn))))
  294.               dactn-nodes->graph-nodes))
  295.      99                                                    ; DEPTH-BOUND 
  296.      :vertical-tree                                        ; STYLE
  297.      :as-found                                             ; ORDERING
  298.      node-font
  299.      '("chicago" 12)                                       ; TEXT-FONT
  300.      10                                                    ; BORDER-WIDTH 
  301.      nil                                                   ; INFO 
  302.      #'dactn-mouse-method)))                               ; MOUSE-METHOD
  303.  
  304. (eval-when (compile eval)
  305.   (defmacro REMAKE-DACTN-VIEW (gw gv object-spec)
  306.     (declare (ignore gv))
  307.     `(ccl:ask ,gw
  308.               (let ((new-gv (dactn->graph-view (object-spec-owner ,object-spec))))
  309.               (grapher:set-graph-view new-gv)
  310.               (ccl:set-window-title 
  311.                (sm:prints 'grapher:graph-view new-gv :style :name :stream nil))
  312.               (ccl:window-select)
  313.               (ccl:view-draw-contents)
  314.               (unless (grapher:windows-using-graph-view gv)
  315.                 (grapher:dispose-graph-view gv)))))
  316.   )
  317.  
  318. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  319. ;;; Editing DACTN as a whole
  320.  
  321. (defun DACTN-MOUSE-METHOD-FOR-DACTN (gw gv gn object-spec)
  322.   (declare (symbol gv gn) (list object-spec))
  323.   (let* ((dactn (object-spec-owner object-spec))
  324.          (dactn-struct (sm:gets 'dactn dactn))
  325.          (edit-action
  326.           (wind:menu-dialogue
  327.            '(|Create New Node| |Change Start Node| |Delete Node| |Interpret DACTN|
  328.              |Update Graph for Changes| |Change Comments| |Change Type|
  329.              |Edit LISP Definition| |Inspect this DACTN| |Inspect Graph Node|)
  330.            "What do you want to do with DACTN ~S?" dactn)))
  331.     (declare (symbol dactn edit-action))
  332.     (ecase edit-action
  333.       ((|Create New Node|)
  334.        (push (get-new-node-from-user dactn) (dactn-nodes dactn-struct))
  335.        (dactn-modified dactn)
  336.        (remake-dactn-view gw gv object-spec))
  337.       ((|Change Start Node|)
  338.        (setf (dactn-start-node dactn-struct)
  339.              (wind:menu-dialogue (dactn-node-names dactn)
  340.                                  "What is the new start node for ~S?" dactn))
  341.        (dactn-modified dactn)
  342.        (remake-dactn-view gw gv object-spec))
  343.       ((|Delete Node|)
  344.        (let ((node (wind:menu-dialogue (dactn-node-names dactn)
  345.                                        "Delete what node from ~S?" dactn)))
  346.          (cond
  347.           ((eq node (dactn-start-node dactn-struct))
  348.            (ccl:ed-beep) 
  349.            (wind:message-dialogue 
  350.             "Node ~A is currently the start node, and cannot be deleted."
  351.             node))
  352.           ((member node (nodes-referenced-by-arcs dactn-struct))
  353.            (ccl:ed-beep)
  354.            (wind:message-dialogue
  355.             "Node ~A is referenced by an arc out of another node, and cannot be deleted."
  356.             node))
  357.           (T
  358.            (setf (dactn-nodes dactn-struct)
  359.                  (delete node (dactn-nodes dactn-struct)
  360.                          :key #'car))
  361.            (dactn-modified dactn)
  362.            (remake-dactn-view gw gv object-spec)))))
  363.       ((|Interpret DACTN|)
  364.        (ccl:eval-enqueue `(interpret-dactn ',(object-spec-owner object-spec))))
  365.       ((|Update Graph for Changes|)
  366.        (remake-dactn-view gw gv object-spec))
  367.       ((|Change Comments|) ; must improve: no good for multi-lined comments.
  368.        (setf (dactn-comments dactn-struct)
  369.              (wind:get-string-default-dialogue 
  370.               (dactn-comments dactn-struct)
  371.               "Please provide your new comments for DACTN ~S" dactn))
  372.        (dactn-modified dactn))
  373.       ((|Change Type|)
  374.        (setf (dactn-type dactn-struct)
  375.              (read-from-string
  376.               (wind:get-string-dialogue
  377.                "What is the new type classification for ~S?" dactn)))
  378.        (dactn-modified dactn))
  379.       ((|Edit LISP Definition|) ; :after-edit method for dactn will mark as modified
  380.        (sm:edits 'dactn dactn)
  381.        (wind:message-dialogue
  382.         "You are responsible for redrawing the DACTN graph when done."))
  383.       ((|Inspect this DACTN|)       (inspect dactn-struct))
  384.       ((|Inspect Graph Node|)  (inspect (sm:gets 'grapher:graph-node gn))))))
  385.  
  386. (defun GET-NEW-NODE-FROM-USER (dactn)
  387.   ;; Returns minimally operational node.
  388.   (let ((node-name (read-from-string
  389.                     (wind:get-string-dialogue 
  390.                      "Give a symbolic name for a new node in ~S:" dactn))))
  391.     (if (member node-name (dactn-node-names dactn))
  392.       (progn (ccl:ed-beep) (wind:message-dialogue "That node already exists."))
  393.       (cons node-name
  394.             (make-dactn-node
  395.              :action (get-action-from-user node-name dactn))))))
  396.  
  397. (defun GET-ACTION-FROM-USER (node-name dactn)
  398.   (let ((type (wind:menu-dialogue 
  399.                '("Regular DACTN-Action" "Invoke another DACTN")
  400.                "What kind of action is ~S in ~S to have?" node-name dactn)))
  401.     (if (string= type "Regular DACTN-Action")
  402.       (list :action (get-action-name-from-user 
  403.                      "What DACTN-Action will be invoked at node ~S?" node-name))
  404.       (list :dactn  (get-dactn-name-from-user
  405.                      "What DACTN will be invoked at node ~S?" node-name)))))
  406.  
  407. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  408. ;;; Editing DACTN nodes
  409.  
  410. (defun DACTN-MOUSE-METHOD-FOR-DACTN-NODE (gw gv gn object-spec)
  411.   (declare (symbol gv gn) (list object-spec))
  412.   (let* ((dactn  (object-spec-owner object-spec))
  413.          (node   (car (object-spec-itself object-spec)))
  414.          (struct (cdr (object-spec-itself object-spec)))
  415.          (edit-action
  416.           (wind:menu-dialogue
  417.            (if (eq (first (second (third object-spec))) :dactn)
  418.              '(|Graph Nested DACTN|
  419.                |Add Arc| |Change Arc Ordering| |Delete Arc|
  420.                |Change Associated Action| |Edit Associated Action|
  421.                |Edit ARG-GEN| |Inspect this DACTN Node| |Inspect Graph Node|)
  422.              '(|Add Arc| |Change Arc Ordering| |Delete Arc|
  423.                |Change Associated Action| |Edit Associated Action|
  424.                |Edit ARG-GEN|  |Inspect this DACTN Node| |Inspect Graph Node|))
  425.            "What do you want to do with node ~S in DACTN ~S?" node dactn)))
  426.     (declare (symbol dactn node edit-action))
  427.     (case edit-action
  428.       ((|Graph Nested DACTN|)
  429.          (graph-dactn (second (second (object-spec-itself object-spec)))))
  430.       ((|Add Arc|)
  431.        (setf (dactn-node-arcs struct)
  432.              (nconc (dactn-node-arcs struct) (list (get-arc-from-user dactn node))))
  433.        (dactn-modified dactn)
  434.        (remake-dactn-view gw gv object-spec))
  435.       ((|Change Arc Ordering|)
  436.        (setf (dactn-node-arcs struct) 
  437.              (get-arc-order-from-user node (dactn-node-arcs struct)))
  438.        (dactn-modified dactn)
  439.        (remake-dactn-view gw gv object-spec))
  440.       ((|Delete Arc|)
  441.        (setf (dactn-node-arcs struct)
  442.              (remove-arc-specified-by-user node (dactn-node-arcs struct)))
  443.        (dactn-modified dactn)
  444.        (remake-dactn-view gw gv object-spec))
  445.       ((|Change Associated Action|)
  446.        ;; Whether regraphing depends on whether changed between dactn-action and dactn
  447.        (let ((prev-action (first (dactn-node-action struct))))
  448.          (setf (dactn-node-action struct) (get-action-from-user node dactn))
  449.          (unless (eq prev-action (first (dactn-node-action struct)))
  450.            (remake-dactn-view gw gv object-spec))
  451.          (dactn-modified dactn)))
  452.       ((|Edit Associated Action|)
  453.        ;; This does not constitute modification of the DACTN in itself
  454.        (if (eq (first (dactn-node-action struct)) :action)
  455.          (sm:edits 'dactn-action (second (dactn-node-action struct)))
  456.          (sm:edits 'dactn (second (dactn-node-action struct)))))
  457.       ((|Edit ARG-GEN|)
  458.        ;; This needs to be abstracted out!
  459.        (let* ((title (format nil "<ARG-GEN for ~A in ~A>" node dactn))
  460.               (*print-pretty* t)
  461.               (setf-string
  462.                (format nil 
  463.                        ";;; Evaluate buffer when done editing~
  464.                         ~%(setf (dactn::dactn-node-arg-gen~
  465.                         ~%       (cdr (assoc '~S~
  466.                         ~%                   (dactn::dactn-nodes (sm:gets 'dactn:dactn '~S)))))~
  467.                         ~%~
  468.                         ~%      '~A~
  469.                         ~%~
  470.                         ~%      )~
  471.                         ~%(dactn:dactn-modified '~S)
  472.                         ~%(ccl:ask (ccl:front-window) (ccl:window-close))"
  473.                        node dactn (prin1-to-string (dactn-node-arg-gen struct)) dactn))
  474.               (the-editor nil) (width 0) (height 0))
  475.          (multiple-value-bind 
  476.            (columns rows)
  477.            (wind:message-size setf-string)
  478.            (declare (integer columns rows) (optimize speed))
  479.            (setf columns (max columns (+ 10 (length title))))
  480.            (setf width  (min 580 (max 250 (* 7 columns))))
  481.            (setf height 
  482.                  (min 300
  483.                       (max 100
  484.                            (cond ((< rows 4)  (* (+ 4 sm::*editor-window-font-height*)
  485.                                                  rows))
  486.                                  ((< rows 12) (* (+ 2 sm::*editor-window-font-height*)
  487.                                                  rows))
  488.                                  (t (* sm::*editor-window-font-height* rows)))))))
  489.          (setf the-editor
  490.                (ccl:oneof ccl:*fred-window*
  491.                           :window-title title
  492.                           :window-position (sm:next-window-position width height)
  493.                           :window-size (ccl:make-point width height)
  494.                           :window-show t
  495.                           :window-font sm::*editor-window-font*
  496.                           :window-type :document-with-zoom
  497.                           :close-box-p t
  498.                           :scratch-p t
  499.                           :package *package*))
  500.          (ccl:buffer-insert (ccl:ask the-editor (ccl:window-buffer)) setf-string)
  501.          (ccl:ask the-editor (ccl:window-update))))
  502.       ((|Inspect this DACTN Node|) (inspect struct))
  503.       ((|Inspect Graph Node|)      (inspect (sm:gets 'grapher:graph-node gn))))))
  504.  
  505. (defun DACTN-MOUSE-METHOD-FOR-EXIT (gw gv gn object-spec)
  506.   (declare (symbol gn) (list object-spec) (ignore gv gw))
  507.   (let* ((dactn  (object-spec-owner object-spec))
  508.          (edit-action
  509.           (wind:menu-dialogue
  510.                '(|Inspect this Exit Object| |Inspect Graph Node|)
  511.                "What do you want to do with this Exit in ~S?" dactn)))
  512.     (declare (symbol dactn edit-action))
  513.     (case edit-action
  514.       ((|Inspect this Exit Object|) (inspect object-spec))
  515.       ((|Inspect Graph Node|)       (inspect (sm:gets 'grapher:graph-node gn))))))
  516.  
  517. (defun GET-ARC-FROM-USER (dactn node)
  518.   (let* ((test (get-test-name-from-user 
  519.                 "What DACTN-Test do you want on the new arc for ~A?" node))
  520.          (target
  521.           (wind:menu-dialogue (cons :exit (dactn-node-names dactn))
  522.                               "If ~A succeeds, Go To which node?"
  523.                               test)))
  524.     (if (eq target :exit)
  525.       (list test :exit)
  526.       (list test :goto target))))
  527.  
  528. (defun GET-ARC-ORDER-FROM-USER (node arcs)
  529.   (do ((new-arcs (list :head))
  530.        (chosen-arc nil)
  531.        (count 1 (1+ count)))
  532.       ;; Don't force them to choose the last arc from a menu, but watch for null arcs.
  533.       ((null (cdr arcs)) 
  534.        (if arcs (append (cdr new-arcs) arcs) (cdr new-arcs)))
  535.     (setf chosen-arc
  536.           (wind:menu-dialogue arcs 
  537.                               "Which arc is #~A in the arc ordering for ~A?"
  538.                               count node))
  539.     (setf arcs (delete chosen-arc arcs :test #'equal))
  540.     (nconc new-arcs (list chosen-arc))))
  541.  
  542. (defun REMOVE-ARC-SPECIFIED-BY-USER (node arcs)
  543.   (if (null (rest arcs))
  544.     nil
  545.     (remove (wind:menu-dialogue arcs "Delete which arc from the arcs for ~A?" node)
  546.             arcs :test #'equal)))
  547.  
  548. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  549. ;;; Editing DACTN ARCS
  550.  
  551. (defun DACTN-MOUSE-METHOD-FOR-DACTN-ARC (gw gv gn object-spec)
  552.   (declare (symbol gv gn) (list object-spec))
  553.   (let* ((dactn (object-spec-owner object-spec))
  554.          (node (car (object-spec-itself object-spec)))
  555.          (arc  (cdr (object-spec-itself object-spec)))
  556.          (edit-action
  557.           (wind:menu-dialogue
  558.            (ccase (second arc)
  559.              ((:goto)
  560.               '(|Change Target Node| 
  561.                 |Change Test| |Change Arc Type| |Edit Test| |Inspect Graph Node|))
  562.              ((:exit)
  563.               '(|Change Test| |Change Arc Type| |Edit Test| |Inspect Graph Node|)))
  564.            "What do you want to do with arc ~%~S~%belonging to node ~S in DACTN ~S?"
  565.            arc node dactn)))
  566.     (case edit-action
  567.       ((|Change Target Node|)
  568.        (setf (third arc)
  569.              (wind:menu-dialogue (dactn-node-names dactn)
  570.                                  "Choose node to Go To from ~S:" node))
  571.        (dactn-modified dactn)
  572.        (remake-dactn-view gw gv object-spec))
  573.       ((|Change Test|)
  574.        (setf (first arc) 
  575.              (get-test-name-from-user "Choose new DACTN-TEST for~%~S:" arc))
  576.        (dactn-modified dactn)
  577.        (remake-dactn-view gw gv object-spec))
  578.       ((|Change Arc Type|)
  579.        (setf (second arc) (wind:menu-dialogue *arc-types*
  580.                                               "Choose new arc-type for~%~S:" arc))
  581.        (dactn-modified dactn)
  582.        (case (second arc)
  583.          ((:exit) (setf (cddr arc) nil))
  584.          ((:goto)
  585.           (if (null (cddr arc))
  586.             (setf (cddr arc)
  587.                   (list (wind:menu-dialogue (dactn-node-names dactn)
  588.                                             "Choose node to Go To from ~S:" node))))))
  589.        (remake-dactn-view gw gv object-spec))
  590.       ((|Edit Test|) (sm:edits 'dactn-test (first arc)))
  591.       ((|Inspect Graph Node|) (inspect (sm:gets 'grapher:graph-node gn))))))
  592.  
  593. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  594. ;;; Helpers
  595.  
  596. (defun GET-DACTN-NAME-FROM-USER (message &rest args)
  597.   (let ((dactn
  598.          (wind:menu-dialogue 
  599.           (cons "Make a New DACTN" (sm:instances 'dactn))
  600.           (apply #'format nil message args))))
  601.     (when (equal "Make a New DACTN" dactn)
  602.       (setf dactn (sm:new-instance-name 'dactn))
  603.       (funcall (sm:creator 'dactn) dactn)
  604.       (graph-dactn dactn))
  605.     dactn))
  606.  
  607. (defun GET-TEST-NAME-FROM-USER (message &rest args)
  608.   (let ((test 
  609.          (wind:menu-dialogue 
  610.           (cons "Make a New Test" (sm:instances 'dactn-test))
  611.           (apply #'format nil message args))))
  612.     (when (equal "Make a New Test" test)
  613.       (setf test (sm:new-instance-name 'dactn-test))
  614.       (funcall (sm:creator 'dactn-test) test)
  615.       (sm:edits 'dactn-test test))
  616.     test))
  617.  
  618. (defun GET-ACTION-NAME-FROM-USER (message &rest args)
  619.   (let ((action 
  620.          (wind:menu-dialogue 
  621.           (cons "Make a New Action" (sm:instances 'dactn-action))
  622.           (apply #'format nil message args))))
  623.     (when (equal "Make a New Action" action)
  624.       (setf action (sm:new-instance-name 'dactn-action))
  625.       (funcall (sm:creator 'dactn-action) action)
  626.       (sm:edits 'dactn-action action))
  627.     action))
  628.  
  629. (defun DACTN-NODE-NAMES (dactn)
  630.   (mapcar #'car (dactn-nodes (sm:gets 'dactn dactn))))
  631.  
  632. (defun NODES-REFERENCED-BY-ARCS (dactn-struct)
  633.   (let ((nodes-referenced nil))
  634.     (dolist (node-name+struct (dactn-nodes dactn-struct))
  635.       (dolist (test+arc (dactn-node-arcs (cdr node-name+struct)))
  636.         (if (eq (first (cdr test+arc)) :goto)
  637.           (push (second (cdr test+arc)) nodes-referenced))))
  638.     nodes-referenced))
  639.  
  640. (defun SAVE-DACTN (dactn path)
  641.   "save-dactn <dactn>                                              [Function]
  642.   Writes the macro definitions of <dactn> to a file specified by <path>."
  643.   (check-type dactn symbol)
  644.   (assert (sm:gets 'dactn dactn) (dactn)
  645.           "[GRAPHER:SAVE-DACTN] Unknown dactn ~S" dactn)
  646.   (check-type path (or simple-string pathname))
  647.   (let ((*print-pretty* nil) (*print-escape* t)
  648.         (*print-circle* nil) (*print-case* :upcase) (*print-array* t)
  649.         #+:ccl (ccl:*print-structure* t))
  650.     (with-open-file (stream path
  651.                             :direction :output
  652.                             :if-exists :supersede)
  653.       (format stream ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  654. ;;; Graph View ~S~%;;; Saved by SAVE-DACTN ~A~%;;; On ~A, a ~A~%"
  655.               dactn
  656.               (multiple-value-bind
  657.                 (second minute hour date month year)
  658.                 (get-decoded-time)
  659.                 (declare (integer second minute hour date month year))
  660.                 (format nil "~2,'0D-~A-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
  661.                         date 
  662.                         (case month
  663.                           ((1) "Jan") ((2) "Feb") ((3) "Mar") ((4) "Apr")
  664.                           ((5) "May") ((6) "Jun") ((7) "Jul") ((8) "Aug")
  665.                           ((9) "Sep") ((10) "Oct") ((11) "Nov") ((12) "Dec"))
  666.                         (- year 1900)
  667.                         hour minute second))
  668.               (machine-instance)
  669.               (machine-type))
  670.       (format stream "~%(in-package ~S)~%~%" (package-name *package*))
  671.       (sm:prints 'dactn dactn :style :pretty-macro :stream stream)
  672.       (format stream "~&~%;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  673. ;;; EOF"))
  674.     path))
  675.  
  676. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  677.  
  678. (defparameter *DACTN-MENU*
  679.   (let* ((line-item
  680.           (ccl:oneof ccl:*menu-item*
  681.                      :menu-item-title "-"))
  682.          (graph-item 
  683.           (ccl:oneof ccl:*menu-item*
  684.                      :menu-item-title "Graph/Edit DACTN ..."
  685.                      :menu-item-action 
  686.                      #'(lambda ()
  687.                          (let ((dactn
  688.                                 (wind:menu-dialogue 
  689.                                  (sm:instances 'dactn)
  690.                                  "Which DACTN do you wish to graph and edit?")))
  691.                            (graph-dactn dactn)))))
  692.          (label-type-item
  693.           (ccl:oneof ccl:*menu-item*
  694.                      :menu-item-title "Label Using Action Names"
  695.                      :menu-item-action 
  696.                      '(progn (setf  *label-using-action-names*
  697.                                     (not *label-using-action-names*))
  698.                        (if  *label-using-action-names*
  699.                          (ccl:set-menu-item-check-mark t)
  700.                          (ccl:set-menu-item-check-mark nil)))))
  701.          (new-dactn-item 
  702.           (ccl:oneof ccl:*menu-item*
  703.                      :menu-item-title "New DACTN ..."
  704.                      :menu-item-action 
  705.                      #'(lambda ()
  706.                          (let ((dactn-name (sm:new-instance-name 'dactn)))
  707.                            (create-dactn dactn-name)
  708.                            (dactn-modified dactn-name)
  709.                            (graph-dactn dactn-name)))))
  710.          (modified-dactns-item 
  711.           (ccl:oneof ccl:*menu-item*
  712.                      :menu-item-title "Modified DACTNs ..."
  713.                      :menu-item-action 
  714.                      #'(lambda ()
  715.                          (dolist (dactn (wind:multiple-menu-dialogue 
  716.                                          (modified-dactns)
  717.                                          "These DACTNs are currently marked as modified.  Select any you wish to unmodify."))
  718.                            (dactn-unmodified dactn)))))
  719.          (save-item
  720.           (ccl:oneof ccl:*menu-item*
  721.                      :menu-item-title "Save DACTN ..."
  722.                      :menu-item-action
  723.                      #'(lambda ()
  724.                          (let* ((d (wind:menu-dialogue
  725.                                     (sm:instances 'dactn)
  726.                                     "Which DACTN do you want to save?"))
  727.                                 (file-path
  728.                                  (pathname 
  729.                                   (ccl:choose-new-file-dialog
  730.                                    :prompt 
  731.                                    (format nil "Save ~A to ..." d))))
  732.                                 (backup-path
  733.                                  (make-pathname
  734.                                   :host      (pathname-host file-path)
  735.                                   :device    (pathname-device file-path)
  736.                                   :directory (pathname-directory file-path)
  737.                                   :name      (pathname-name file-path)
  738.                                   :type      "bak")))
  739.                            (if (probe-file file-path)
  740.                              (progn
  741.                                (if (probe-file backup-path)
  742.                                  (delete-file backup-path))
  743.                                (rename-file file-path backup-path)
  744.                                (format T "~&;~A backed up to ~A" 
  745.                                        (namestring file-path)
  746.                                        (namestring backup-path))))
  747.                            (setf *default-instance-file-path*
  748.                                  (directory-namestring file-path))
  749.                            (ccl:eval-enqueue
  750.                             `(progn
  751.                                (save-dactn ',d ',file-path)
  752.                                (dactn-unmodified ',d)
  753.                                (format T "~&;DACTN ~A saved to ~S"
  754.                                        ',d
  755.                                        ',(namestring file-path))))))))
  756.          (interpret-item
  757.           (ccl:oneof ccl:*menu-item*
  758.                      :menu-item-title "Interpret DACTN"
  759.                      :menu-item-action 
  760.                      #'(lambda ()
  761.                          (ccl:eval-enqueue
  762.                           '(interpret-dactn 
  763.                             (wind:menu-dialogue
  764.                              (sm:instances 'dactn)
  765.                              "Which DACTN do you want to Interpret?"))))))
  766.          (trace-item
  767.           (ccl:oneof ccl:*menu-item*
  768.                      :menu-item-title "Trace DACTNs"
  769.                      :menu-item-action 
  770.                      '(progn (setf *trace-dactns*
  771.                                    (not *trace-dactns*))
  772.                        (if *trace-dactns*
  773.                          (ccl:set-menu-item-check-mark t)
  774.                          (ccl:set-menu-item-check-mark nil)))))
  775.          (dispose-item
  776.           (ccl:oneof ccl:*menu-item*
  777.                      :menu-item-title "Hide This Menu"
  778.                      :menu-item-action 
  779.                      '(ccl:ask *dactn-menu* (ccl:menu-deinstall))))
  780.          (dactn-menu (ccl:oneof ccl:*menu* 
  781.                                 :menu-title "DACTN"
  782.                                 :menu-items (list interpret-item
  783.                                                   trace-item
  784.                                                   line-item
  785.                                                   graph-item
  786.                                                   label-type-item
  787.                                                   line-item
  788.                                                   new-dactn-item
  789.                                                   modified-dactns-item
  790.                                                   save-item
  791.                                                   line-item
  792.                                                   dispose-item))))
  793.     (ccl:defobfun (ccl:menu-item-update label-type-item) ()
  794.                   (if  *label-using-action-names*
  795.                     (ccl:set-menu-item-check-mark t)
  796.                     (ccl:set-menu-item-check-mark nil)))
  797.     (ccl:defobfun (ccl:menu-item-update trace-item) ()
  798.                   (if *trace-dactns*
  799.                     (ccl:set-menu-item-check-mark t)
  800.                     (ccl:set-menu-item-check-mark nil)))
  801.     (ccl:ask dactn-menu (ccl:menu-install))
  802.     (ccl:ask line-item (ccl:menu-item-disable))
  803.     ;; Menu-dispose dumped from version 1.3.1?
  804.     (if (and (boundp '*dactn-menu*) 
  805.              (typep *dactn-menu* ccl:*menu*))
  806.       (ccl:ask *dactn-menu* (ccl:menu-deinstall)))
  807.     dactn-menu))
  808.  
  809. (ccl:ask ccl:*tools-menu*
  810.   (ccl:add-menu-items
  811.    (ccl:oneof ccl:*menu-item*
  812.           :menu-item-title "Restore DACTN Menu"
  813.           :menu-item-action
  814.           #'(lambda ()
  815.               (ccl:ask *dactn-menu*
  816.                 (unless (ccl:menu-installed-p) (ccl:menu-install)))))))
  817.  
  818. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  819. (provide :dactn-browser)
  820. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  821. ;;; EOF
  822.